perm filename NOTES.F4[P11,LCS]1 blob
sn#592322 filedate 1981-06-09 generic text, type T, neo UTF8
C**** NOTWRT, STEM
C**** ORDNT, LDGLN, TAILS, DOTIT, SAVEM, GETEM ****
C***** ACCI, DIAMND, RST ***********
C*** MRK, YPOS, R4SET, MRKZ, TENUTO, MRKX ***************
SUBROUTINE NOTWRT
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON /STF/RSTFAC(0/7),RSTJ2 /WIDTH/WID1,WID2,WIDX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON /POSI/STFF(0/7),JJ2,POS
C ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ,
1 PUNCT,JY,RJ
EQUIVALENCE (J4,JQ(2)),(J5,JQ(3)),(R4,RJQ(2)),(J9,JQ(7))
1,(R6,RJQ(4)),(J7,JQ(5)),(J10,JQ(8)),(J11,JQ(9)),(J6,JQ(4))
1,(R3,RJQ(1)),(RX4,JQ(19)),(R12,RJQ(10)),(RLVL,RJQ(20))
1,(R7,RJQ(5))
DATA WID1/14.54/,WID2/16.2/
C NOTES****
RMINI=RSTJ2
RST7=7.*RMINI
IF(JA.EQ.1)GO TO 11
IF(JA.NE.9)GO TO 90
CALL MRKX
RETURN
90 CALL RST
C GO MAKE A REST
RETURN
11 JSTEM=J5/10
JWHOLE=IABS(J6)
IF(JWHOLE.EQ.30)JWHOLE=0
C 30 IS USED IN NOTBMS & RHYTH.
JACC=MOD(J5,10)
C THE ACCIDENTAL NUM.
JTAIL=MOD(J7,10)
C HOW MANY TAILS
JDOT=J7/10
C HOW MANY DOTS
NTYPE=(IABS(J4)+20)/100
C NOTE TYPE CODE NUMBER (0,1,2,3,4,5)
RLVL=AMOD(R4,100.)
C TRUE LEVEL OF NOTE. USED IN ACCI.
IF(J10.LE.0)GO TO 9
POS=STFF(J2-3+2*J10)
C FOR PUTTING NOTES ON STAFF ABOVE OR BELOW. J10=1=DOWN, =2=UP
CALL CENTX
9 MKS=J11
C ANY MARKS?
JJ4=RLVL
RJAC=R3
C SAVE HOR. POS. FOR OTHER ROUTINES
IF(R12.NE.0)RMINI=RMINI*R12
C R12 HAS NEW, MASTER SIZE FACTOR
GO TO (1,2,3,3,5,6)NTYPE+1
1 CALL ORDNT
7 IF(JJ4.LT.2)GO TO 8
IF(JJ4.LT.13)GO TO 10
8 IF(J9.NE.-1)CALL LDGLN
10 IF(JDOT.EQ.0)GO TO 12
RJX=RJAC+(22.+AMOD(R7,1.0)*59.6)*RMINI
C RJAC IS ORIGINAL R3 (RESTS ALSO USE DOTIT)
CALL DOTIT
12 IF(JACC.NE.0)CALL ACCI
IF(JSTEM.GT.0)CALL STEM
IF(JTAIL.NE.0)CALL TAILS
IF(MKS.NE.0)CALL MRK
RETURN
2 RMINI=RMINI*.6
C FOR MINI (GRACE) NOTES
GO TO 1
3 CALL DIAMND
GO TO 7
5 RB=R6*RST7
C USE R6 TO ADJUST SOURCE POS. OF HEADLESS NOTES (WAS R12)
J6=0
GO TO 7
6 CALL EXTRA
C GO USE SPECIAL NOTE PACKAGE
END
SUBROUTINE STEM
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM
COMMON /STF/RSTFAC(0/7),RSTJ2 /WIDTH/WID1,WID2,WIDX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
C ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ,PUNCT,JY,RJ
EQUIVALENCE (J5,JQ(3)),(J7,JQ(5)),(J10,JQ(8)),
1(J6,JQ(4)),(R5,RJQ(3)) ,(R8,RJQ(6)),(R3,RJQ(1))
RG=(JTAIL-1)*14
IF(RG.LT.0)RG=0
C 999 IS STANDARD (0) STEM LENGTH.
IF(R8.NE.999.)GO TO 1751
R8=0
RH=0
GO TO 2751
1751 IF(R8.LT.999.)GO TO 751
R8=R8-1000.
J10=-1
C +1000 PUTS SLASH ON NOTE STEM
751 RH=R8*RST7
2751 IF(JSTEM.NE.2)GO TO 1280
C STEM EXTENSIONS ARE BY NOTE #S
RJX=R3
C FOR STEM DOWN (=2)
RG=-RG-48.
RH=-RH
C RB IS SOURCE POS. OF STEM. SET UP IN VARIOUS NOTE ROUTINES.
RB=-RB
C FOR TILT OF ORDINARY NOTES (NOT X OR DIAMOND)
GO TO 129
C NEXT IS FOR STEM UP.
1280 RJX=WIDX
CC IF(J6.LT.0)RJX=WID2
C IF(J6.LT.0)GET SPACE FOR HALF NOTE
2322 RJX=RJX*RMINI+R3
RG=RG+48.
129 RZ=CENTR+RH+RG*RMINI
RB=RB+CENTR
CALL LINX(RJX,RB,RJX,RZ)
C MOVES CENTR UP OR DOWN FOR NEXT TAIL
END
SUBROUTINE ORDNT
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
CC COMMON/DAT/RACNT(69),RDOT(17),JXAC(7),RNOTE(22)
COMMON/DAT/RAC(69),RDT(17),XAC(7),RNTE(22),RACCI(22),NACCI(3)
COMMON /STF/RSTFAC(0/7),RSTJ2 /WIDTH/WID1,WID2,WIDX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON/PLTR/IPLT,RHT,DIS /POSI/STFF(0/7),JJ2,POS
C ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R4,RJQ(2))
1,(R6,RJQ(4)),(J7,JQ(5)),(J6,JQ(4)),(R5,RJQ(3))
1,(R8,RJQ(6)),(R7,RJQ(5)),(R3,RJQ(1)),(RLVL,RJQ(20))
RB=RMINI+RMINI
C RB SETS SOURCE FOR STEM
WIDX=WID1
C GET STANDARD NOTE WIDTH
IF(J6.LT.0)WIDX=WID2
C P6<0 = WHITE NOTE
C GETS WIDTH OF NOTE DISPLACEMENT
RQ=WIDX
IF(JWHOLE.LT.10)GO TO 1
C SHIFT NOTE TO LEFT OR RIGHT OF STEM (R6=20,10)
C P6 FOR HOMING TO RIGHT(10) OR LEFT(20) OF STEM(10=UP, 20=DOWN)
IF(JWHOLE.EQ.20)RQ=-RQ
R3=R3+RQ*RMINI
1 IF(J6.GE.0)GO TO 125
KL=1
RG=7.
C FOR WHITE NOTES ON DPY.
J7=MOD(J7,10)
IF(J7.EQ.0)GO TO 12122
IF(JTAIL.NE.0)JSTEM=-JSTEM
C SAVE NEG. STEM DIRECTION FOR MARKS ROUTINE
JTAIL=0
IF(IPLT.LT.0)GO TO 2121
IF(J7.NE.2)GO TO 1253
C NO DOTTED DOUBLE WHOLE NOTE??
RQ=POS-18.*RSTJ2+RST7*(RLVL-1.)
CC RQ=POS-18.*RSTJ2+RST7*(R4-1.)
CALL LINX(R3,RQ,R3,RQ+RST7+RST7)
C PUT IN LINE TO SHOW DBL WHOLE ON SCREEN (P7=2)
C SET STEM SHIFT FLAG(J6) FOR ORD. WIDTH NOTES.
12122 IF(IPLT.GE.0)GO TO 1253
2121 J5=15+J7
C IF J7=1, THEN WHOLE NOTE SHAPE INSTEAD OF HALF. (J7=2=DBL. WHL.)
12121 RG=RSTJ2
C RG FOR NOW ;FIX THIS SOME DAY↓↓ SEE 1342+1!
JX4=J4
RQ=R7
CALL DRWNT
C SAVE IT FOR DOTS
C DO I NEED TO NOW?
R7=RQ
CC R4=RX4
J4=JX4
C GET 'EM BACK
RSTJ2=RG
C DRAWS GOOD NOTES ON PLOTTER, NOT ON DPY
RETURN
1251 CALL NOIR(RMINI)
C FOR QUARTER NOTES ON PLOTTER.
RETURN
125 IF(IPLT.LT.0)GO TO 1251
RG=22.
KL=17
1253 CALL RDRAW(KL,RG,RNTE,RMINI,R3,CENTR,RMINI)
END
C********* FOR LEDGER LINES *********
SUBROUTINE LDGLN
COMMON /STF/RSTFAC(0/7),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/POSI/STFF(0/7),JJ2,POS
C ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (J4,JQ(2)),(J9,JQ(7)) ,(R3,RJQ(1)),(J6,JQ(4))
1,(J12,JQ(10)),(RLVL,RJQ(20))
J4=RLVL
IF(J4.LT.2)GO TO 1
J12=(J4+1)/2-6
C J12 FOR LEDGER LINES ABOVE STAFF
GO TO 2
1 J12=-((3-J4)/2)
C BELOW STAFF
2 RJW=R3-7.*RMINI
RZ=R3+20.*RMINI
IF(J12.LT.0)GO TO 71
JX=J12
JRX=13
GO TO 711
71 JRX=J12*2+3
JX=-J12
711 RX=POS-18*RSTJ2+RST7*JRX
IF(J6.LT.0)RZ=RZ+2*RMINI
126 CALL LINX(RJW,RX,RZ,RX)
1126 IF(JX.EQ.1)RETURN
RX=RX+RSTJ2*14.
JX=JX-1
GO TO 126
END
SUBROUTINE TAILS
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /STF/RSTFAC(0/7),RSTJ2
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (R4,RJQ(2)),(R8,RJQ(6)),(J10,JQ(8)),(RLVL,RJQ(20))
R=RMINI/RSTJ2
RJW=2.*R
R4=RLVL
RA=1.
C FOR VERT. SPACING OF MULTIPLE TAILS
IF(JSTEM.NE.2)GO TO 1127
R=-2.7-R8-R
RJW=-RJW
GO TO 2
1127 R=R8-3.+R
C WAS -3.7 OR -2 BECAUSE ORIGINAL DRAWING OF TAIL WAS OFF.
RA=-RA
2 R4=R4+R
C R4 IS USED IN SUBR. TAIL - R8 IS STEM EXTENSION.
R=R8
R8=0
127 CALL TAIL
JTAIL=JTAIL-1
IF(JTAIL.EQ.0)GO TO 1
R=R+RJW
C RR8 SAVES INFO FOR MRK ROUTINE.
R4=R4+RJW
GO TO 127
1 R8=R
CC R4=R4+2.
IF(J10.GE.0)RETURN
C RJX,RZ MUST BE SAVED PROPERLY AFTER USE IN 'STEM'
RJY=-19.
RH=-RSTJ2*4.
IF(JSTEM.EQ.1)GO TO 1327
C IF(RA.LT.0)GO TO 1327
C NEXT IS FOR STEM DOWN SLASH
RJY=23.
RH=RST7
1327 RJX=RJX-RST7
RJY=RZ+RJY*RSTJ2
RZ=RZ+RH
CALL LINX(RJX,RJY,RJX+17.*RSTJ2,RZ)
C FOR SLASH ON GRACE NOTE TAIL
END
SUBROUTINE DOTIT
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
1 /DAT/RAC(69),RDOT(17) /STF/RSF(8),RSTJ2 /WIDTH/WID1,WID2,WIDX
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /PLTR/IPLT,RHT,DIS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (J4,JQ(2)),(J7,JQ(5)),(R3,RJQ(1)),(R7,RJQ(5))
C NEXT FOR NOTES DISPLACED TO LEFT OR RIGHT OF STEM
C MOVES DOT TO RIGHT (THIS SHOULD BE WIDX - BUT OLD FILES WOULD BE WRONG.)
C**** USE WIDX IN FRANCE?
IF(JWHOLE.EQ.20)GO TO 2
IF(JWHOLE.EQ.10.OR.J7.GT.100)RJX=RJX+WID1
2 RJY=CENTR+RSTJ2
IF(MOD(J4,2).EQ.0)GO TO 108
C ON A LINE OR A SPACE?
RX=RST7
IF(J7.GT.100)RX=-RX
C ADD 100 TO R7 FOR DOTS BELOW! NOTE
CC IF(JWHOLE.GE.20.OR.J7.GT.100)RX=-RX
C PERHAPS SHOULD ALWAYS PUT DOT DOWN IF NOTE IS TO LEFT OF STEM??
RJY=RJY+RX
108 RG=9.
IF(IPLT.LT.0)RG=17.
C DOESN'T FILL DOT ON DPY
IF(JDOT.GT.10)JDOT=MOD(JDOT,10)
R=10.*RMINI
107 CALL RDRAW(1,RG,RDOT,RMINI,RJX,RJY,RMINI)
JDOT=JDOT-1
IF(JDOT.EQ.0)RETURN
RJX=RJX+R
CC RJX=RJX+RSTJ2*10.
GO TO 107
END
SUBROUTINE SAVEM
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC /SAV/JJ9,RCEN,RR4,RR6,RR7,RR8,RR9
EQUIVALENCE (R3,RJQ(1)),(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
1,(R7,RJQ(5)),(R8,RJQ(6)),(R9,RJQ(7)),(J9,JQ(7))
RCEN=CENTR
RR4=RLVL
RR6=R6
RR7=R7
RR8=R8
RR9=R9
JJ9=J9
END
SUBROUTINE GETEM
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC /SAV/JJ9,RCEN,RR4,RR6,RR7,RR8,RR9
EQUIVALENCE (R3,RJQ(1)),(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
1,(R7,RJQ(5)),(R8,RJQ(6)),(R9,RJQ(7)),(J9,JQ(7))
CENTR=RCEN
R3=RJAC
RLVL=RR4
R6=RR6
R7=RR7
R8=RR8
R9=RR9
J9=JJ9
END
SUBROUTINE ACCI
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON/DAT/RAC(69),RDT(17),XAC(7),RNTE(22),RACCI(22),NACCI(3)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /STF/RSTFAC(0/7),RSTJ2
COMMON /FONT/JFONT /PLTR/IPLT,RHT /POSI/STFF(0/7),JJ2,POS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY
EQUIVALENCE (R3,RJQ(1)),(J5,JQ(3)),(R5,RJQ(3))
1,(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4))
RX=RMINI
RR3=R3
RR5=AMOD(R5,1.0)
IF(RR5.NE.0)RR3=RR3-RR5*59.6*RMINI
C TO SPACE OUT ACCIDS.
IF(JACC.GT.3)GO TO 3121
C DBL FLT(4) AND DBL SHRP(5) ALWAYS USE 'DRAW' ROUTINE.
C ADD (#) ETC.
IF(IPLT.LT.0)GO TO 3121
IF(JFONT.NE.0)GO TO 3121
NX=NACCI(JACC)
CALL RDRAW(NX+1,RACCI(NX),RACCI,RMINI,RR3,CENTR,RMINI)
RETURN
C TO DRAW GOOD ACCIS ON PLOTTER - NOT ON DPY.(IN CLEF4.DMD)
3121 RA=R3
R3=RR3
C RJZ=AMOD(R4,100.0)
J5=9
IF(JACC.LT.6)GO TO 1
C NEXT FOR (#) ETC.
R6=2.
POS=POS+21.*RMINI
RMINI=RMINI*2.0
C R3=R3-3.*RMINI
J5=99
1 J5=J5+JACC
CALL DRWNT
R3=RA
RMINI=RX
END
SUBROUTINE DIAMND
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON /WIDTH/WID1,WID2,WIDX
COMMON/DAT/RACNT(69),RDOT(17),JXAC(7),RNOTE(22)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /PLTR/IPLT,RHT,DIS,XDIS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (R3,RJQ(1)),(J5,JQ(3)),(R4,RJQ(2)),(R6,RJQ(4))
1,(R7,RJQ(5)),(RX4,JQ(19)),(ISTEM,JQ(20)),(J7,JQ(5)),(J6,JQ(4))
C DIAMOND NTS=180→279
WIDX=WID1
C SET NOTE WIDTH FOR STEM ROUTINE
KL=8
RG=12.0
C FOR DIAMOND NOTES.
RB=0
IF(NTYPE.NE.3)GO TO 3
KL=13
RG=16.
RB=7.*RMINI
C THESE FOR X-NOTE =280→379
3 J4=R4
RJZ=R4
RX4=R4
IF(J6.GE.0)GO TO 1
C NOW FOR BLACK DIAMOND (J6=-1)
J6=0
J5=7
RQ=R7
RG=CENTR
2 CALL DRWNT
R7=RQ
R4=RX4
R6=0
CENTR=RG
RETURN
1 JT=1
C FOR DOUBLE-THICK X NOTES, HARMONICS.
RH=R3
1253 CALL RDRAW(KL,RG,RNOTE,RMINI,RH,CENTR,RMINI)
IF(JT.LT.0)RETURN
IF(IPLT.GE.0)RETURN
RH=RH-1.0
JT=JT-1
GO TO 1253
END
SUBROUTINE RST
COMMON /INTGRS/JACC,JTAIL,JDOT
COMMON R2,JA,CNTR,J2,R3,R4,R5,R6,R7,R8,R9,RJR(12),RX3
1,J3,J4,J5,J6,J7,J8,J9
1/LIMIT/LM,ITEM,LH,I,IX /STF/RF(8),RSTJ2 /XRN/RN(1)
COMMON/PLTR/IPLT,RHT,DIS,XDIS /POSI/STFF(0/7),JJ2,POS
C ITEMS IN FOLLOWING COMMON BLOCK ARE USED IN 'TAILS' AND 'FERM'
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,J5X,RXX,JJJ
IF(IABS(J4).LT.480)GO TO 22
CALL EXTRA
C P4+500= USER-ADDED RESTS
RETURN
22 IF(J6.LT.0)RETURN
C J6=-1= INVIS. RESTS NEEDED IN 'PARTS' PROGRAM
IF(R9.EQ.0)GO TO 302
IF(R9.GT.0)GO TO 2
J9=0
C USE R9 FOR CENTERING. ORIG. P3 IS BASIC POS.
C J9=0 NEEDED FOR CENTERED ./. REPEAT SIGN.**********
C IF R9<0 CENTERING WILL BE DONE IN RSTCEN
C FOR CENTERING WHOLE RESTS
X=1000
C FINAL POSITION WILL BE 1/2 WAY FROM 1ST NOTE POS. TO BARLINE.
DO 1 K=1,ITEM
IF(CODN(K,L).NE.4)GO TO 1
IF(RN(L).GT.2)GO TO 1
C FIND ONLY BARLINES (WDCNT=1)
A=RN(L+3)
IF(A.LT.X.AND.A.GT.RX3)X=A
1 CONTINUE
IF(X.NE.1000)R9=RX3+(X-RX3)/2.-3.0*RSTJ2
C RX3 HAS IMPORTANT POS. INFO FOR NTS.
IF(IPLT.GT.0)GO TO 2
K=I
IF(IPLT.NE.0)K=IX
C PUT R9 INTO NEW PLACE IN XRN
RN(K-1)=R9
2 R3=RHORZ(R9)
R9=0
C R9=0 SO LEDGER LINE FEATURE DOESN'T GET CONFUSED.
302 IF(R8.EQ.-3)R8=0
IF(R8.NE.0.AND.J5.NE.-3)J5=-2
C R8=-4 OR -5 MAKES REPEAT BAR SIGN
C R8=-3 IS FOR 'PAGE' PROGRAM
C SO THAT REST SHAPES ARE NOT CHANGED IN FULL BAR REST.
C R8 PUTS NUM OVER WHL RST ONLY. R5=-3 PUTS DBL WHL UNDER REST.
IF(J5.GT.1)R4=R4-2.
R7=R6*10.
C FOR DOTS
IF(J5.GE.2)R3=R3-3.0*RSTJ2
C SHIFTS 1/16 AND SMALLER RESTS .5 TO LEFT
202 CALL REST
IF(J5.GT.1)GO TO 200
IF(R7.EQ.0)RETURN
201 RA=20.7
R6=0
IF(J5.LT.0)RA=25.7
RJX=R3+RA*RMINI
C RJX HAS HOROZ. POS. FOR DOTIT ROUTINE.
R4=8.+R4
J5=7
C P6=1 THE REST IS DOTTED
JDOT=J6
CALL CENTX
CALL DOTIT
RETURN
200 J5=J5-1
C FOR MULTIPLE TAILS ON 16TH REST, ETC.
R4=R4+2.
CALL RJBX(4.3)
GO TO 202
END
C****** MARKS ON NOTES **********
C 4=WDG, 5=ACCNT, 7 STACC, 9=TEN, 11=DNBOW, 12=UPBOW, 13=HARM, 14=+
C 15=THESIS, 16=ARSIS, 17=MORD, 18= INVMORD, 20=TR, 21=Tb, 22=T#, 23=TNAT
C 25=HVYWDG, 26=FERM, 27=TEN-STACC, 28=WDG-STACC, 29=ACCNT-STACC
C 30-35=FINGERING, 21-23=MUSICA FICTA
SUBROUTINE MRK
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON/DAT/RACNT(69),RDOT(17),NXAC(7)
COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,R11,R12,R13,
1 RRR(8),RLVL,JQ(20) /STF/RSTFAC(0/7),RSTJ2
COMMON /FONT/JFONT /PLTR/IPLT,RHT,DIS,XDIS /POSI/STFF(0/7),JJ2,POS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (J5,JQ(3)),(J11,JQ(9)),(J9,JQ(7))
1,(J3,JQ(1)),(RX4,JQ(19)),(ISTEM,JQ(20)),(J7,JQ(5))
JSTEM=IABS(JSTEM)
MRK=J11/100
C GET MARK CLOSEST TO NOTE HEAD. (LEFT 2 DIGITS)
J5=J11-MRK*100
R11=10.*(R11-J11)
R13=R11
IF(R11.EQ.0)GO TO 100
IF(RSTJ2.NE.RMINI)R11=R11*RMINI/RSTJ2
C***** STEM DIRECTION?????******** (MATTERS FOR J11=4,5,7,9, OR -J11
C SHIFT AWAY FROM NORMAL VERTICAL POS. (.15 SHIFTS UP 1.5 STEPS)
100 RR4=R4
R4=RLVL
R3=RJAC
J4=R4
IF(J5.GT.9)GO TO 10
GO TO(1,1,1,4,5,26,7,5,9)J5
10 IF(J5.GT.19)GO TO 200
GO TO(11,11,11,11,11,11,17,17)J5-10
200 IF(J5.GT.29)GO TO 30
GO TO(20,20,20,20,5,25,26,27,28,29)J5-19
C**** FICTA
1 J5=J5+9
CALL SAVEM
R7=0
R6=.42
C R6 (SIZE) COULD BE CHANGED ****
IF(NTYPE.EQ.1)R6=.26
CALL R4SET(.8,5.8,10.5)
CC R3=R3+15.*RSTJ2
R3=R3+15.*RMINI
R8=0
J9=0
CALL CLEFS
C 29 STILL OPEN FOR MARKS IN SUBR. FERMTA
GO TO 31
C**** WEDGE
4 JX=5
RX=R3+.5*RSTJ2
C SHIFT A LITTLE TO RIGHT
41 CALL YPOS(14.,RY)
RA=RMINI
RB=RA
IF(JSTEM.EQ.1)RA=-RA
40 CALL MRKZ(JX,RY)
GO TO 300
C**** ACCENT
5 JX=1
RX=R3
GO TO 41
C**** STACCATO
7 RX=6.7
RX=R3+RX*RMINI
C PUSH DOT TO RIGHT
RG=9.
IF(IPLT.LT.0)RG=17.
C DOESN'T FILL DOT ON DPY
9 RB=14.
IF(JSTEM.EQ.1)GO TO 70
IF(J4.GT.9)GO TO 73
GO TO 71
70 IF(J4.LT.5)GO TO 73
71 IF(MOD(J4,2).NE.0)RB=21.
73 CALL YPOS(RB,RY)
IF(J5.EQ.9)GO TO 90
77 CALL RDRAW(1,RG,RDOT,RMINI,RX,RY+RSTJ2,RMINI)
GO TO 300
C**** TENUTO (DASH) (STARTS ABOVE)
90 CALL TENUTO(RY)
GO TO 300
C*** UPBOW, ETC.
11 RA=RMINI
RB=RA
RX=R3
CALL R4SET(3.,8.,12.5)
CALL CENTX
CALL MRKZ(NXAC(J5-10),CENTR)
GO TO 300
C*** 17=MORDENT 18=INVERTED MORDENT
17 RINV=J5
CALL R4SET(3.,8.,12.5)
GO TO 260
C*** TRILL
20 CALL R4SET(3.,8.,12.5)
CALL SAVEM
JA=7
R5=0
R7=1.
J7=1
R8=J5-20
C R8 HAS THE ACCIDENTAL TO PUT OVER TR.
CALL ALPHA
GO TO 31
C*** HEAVY WEDGE
25 CALL SAVEM
RINV=1.0
R7=0
RX4=RLVL
ISTEM=JSTEM
CALL FERMTA
GO TO 31
C*** FERMATA
26 CALL SAVEM
RINV=1.
CALL R4SET(2.,7.,11.75)
260 CALL CENTX
CALL FERMTA
GO TO 31
C*** TENUTO-STACC. (DOT CLOSEST TO NOTE HEAD)
27 MRK=-9
270 J5=0
GO TO 7
C*** WEDGE-STACC.
28 MRK=-4
GO TO 270
C*** ACCENT-STACC.
29 MRK=-5
GO TO 270
C*** FINGERING
30 R5=J5-30
C GET THE 1 DIGIT NUM.
C PRINTS ONLY NUMS 0→5 AS FINGERINGS OVER NOTES.
CALL SAVEM
R6=.7
C SIZE OF NUM.
RX=6.
IF(JSTEM.EQ.1)RX=8.
C STEM UP, THEN SHIFT A LITTLE TO RIGHT
J3=R3+RX*RMINI
R7=0
R8=0
R9=0
RA=2.5
IF(JSTEM.EQ.1)RA=-4.
R4=R4+RA
C HGT OF NUM.
CALL MAKNUM(R5)
C ADD HERE FOR NUMS WITH ACCENTS, ETC.
31 CALL GETEM
300 IF(MRK.EQ.0)RETURN
IF(MRK.GT.0)GO TO 301
C WILL ONLY DO CERTAIN COMBINATIONS OF MARKS
C THIS FEATURE NEEDS MORE WORK
MRK=-MRK
C ACCENT,DASH,WEDGE OVER STACC.
IF(MRK.EQ.9)GO TO 304
C JUMP FOR TENUTO. NEXT FOR ACCENT OR WEDGE
IF(JSTEM.EQ.1)GO TO 305
J5=1
IF(J4.GT.9)GO TO 303
306 IF(MOD(J4,2).NE.0)J5=J5*2
GO TO 303
305 J5=-1
IF(J4.LT.5)GO TO 303
GO TO 306
304 IF(JSTEM.EQ.1)GO TO 302
J5=1
IF(J4.LT.9)J5=2
GO TO 303
C WHAT ABOUT IF NO LEDGER LINES?
302 J5=-1
IF(J4.GT.5)J5=-2
303 J4=J4+J5
R4=J4
CALL CENTX
301 J5=MRK
C GET 2ND MARK
MRK=0
GO TO 100
END
SUBROUTINE YPOS(R,RY)
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM
COMMON R2,JA,CENTR,J2,RJQ(9),R12,R13 /STF/RSTFAC(0/7),RSTJ2
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI
RB=R+R13*7.
IF(JSTEM.EQ.1)RB=-RB
C 1=STEM UP, 2=STEM DOWN
RY=RSTJ2
IF(R12.NE.0)RY=RMINI
C FOR NEW GENERAL SIZE FACTOR
RY=CENTR+RB*RY
END
SUBROUTINE R4SET(R,S,T)
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON R2,JA,CENTR,J2,RJQ(20)
EQUIVALENCE (R11,RJQ(9)),(R4,RJQ(2)),(R8,RJQ(6))
Q=R
IF(JSTEM.EQ.1)Q=S+R8
R4=R4+Q
IF(R4.LT.T)R4=T
R4=R4+R11
C R11=DISPLACEMENT ****** CHECK THIS
END
SUBROUTINE MRKZ(JX,Y)
COMMON/DAT/RACNT(69),RDOT(17),NXAC(7)
COMMON R2,JA,CNTR,J2,RJQ(20),J3,J4,J5 /PLTR/IPLT,RHT,DIS,XDIS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,RB
JT=0
IF(IPLT.LT.0)JT=-2
C JT IS FOR THICKENING WHEN PLOTTING
JX1=JX+1
43 CALL RDRAW(JX1,RACNT(JX),RACNT,RA,RX,Y,RB)
IF(JT.EQ.0)RETURN
JT=JT+1
IF(J5.EQ.13)GO TO 42
Y=Y-XDIS
IF(J5.EQ.14)RX=RX-XDIS
C 14=PLUS
GO TO 43
42 RB=RB+.03
C INCREASE SIZE FOR THICKENING HARMONIC
GO TO 43
END
SUBROUTINE TENUTO(Y)
C**** TENUTO (DASH)
COMMON R2,JA,CNTR,J2,R3 /PLTR/IPLT,RHT,DIS,XDIS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX
RX=R3+RMINI*14.
CALL LINX(R3,Y,RX,Y)
IF(IPLT.GE.0)RETURN
C MAKE THICKER IF PLOTTING
Y=Y-XDIS
CALL LINX(R3,Y,RX,Y)
END
C******CODE 9 MARKS **********
C 4=WDG, 5=ACCNT, 7 STACC, 9=TEN, 11=DNBOW, 12=UPBOW, 13=HARM, 14=+
C 15=THESIS, 16=ARSIS, 17=MORD, 18= INVMORD, 20=TR, 21=Tb, 22=T#, 23=TNAT
C 25=HVYWDG, 26=FERM, 27=TEN-STACC, 28=WDG-STACC, 29=ACCNT-STACC
C 30-35=FINGERING, 21-23=MUSICA FICTA
SUBROUTINE MRKX
COMMON /INTGRS/JACC,JTAIL,JDOT,NTYPE,JSTEM,JWHOLE
COMMON/DAT/RACNT(69),RDOT(17),NXAC(7)
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /STF/RSTFAC(0/7),RSTJ2
COMMON /PLTR/IPLT,RHT,DIS,XDIS /POSI/STFF(0/7),JJ2,POS
COMMON/ALF/INP(46),RST7,RST3,RSTX,RMINI,RINV,RA,RX,RJX,RJY,
1 RB,RJW,RZ,JX,RG,KL,RJAC,K,L,RQ,RH,RZTM,RXX,JJJ
EQUIVALENCE (R3,RJQ(1)),(J5,JQ(3)),(R5,RJQ(3)),(R11,RJQ(9))
1,(R4,RJQ(2)),(RLVL,RJQ(20)),(R6,RJQ(4)),(J11,JQ(9)),(J9,JQ(7))
1,(R7,RJQ(5)),(R8,RJQ(6)),(R9,RJQ(7)),(J3,JQ(1)),(RX4,JQ(19))
1,(ISTEM,JQ(20)),(J7,JQ(5))
RMINI=RSTJ2
RINV=1.
IF(J5)2,21,101
C GO BACK IF NO NUM. IN J5
21 RETURN
2 J5=-J5
RINV=-RINV
101 CALL NOZERO(R6)
RMINI=RMINI*R6
JSTEM=0
ISTEM=0
IF(IABS(J4).LT.80)GO TO 100
R4=AMOD(R4,100.)
RMINI=RMINI*.7
100 IF(J5.GT.9)GO TO 10
GO TO(1,1,1,4,5,26,7,5,9)J5
10 IF(J5.GT.19)GO TO 200
GO TO(11,11,11,11,11,11,17,17)J5-10
200 IF(J5.GT.29)GO TO 30
GO TO(20,20,20,20,5,25,26)J5-19
C**** FICTA
1 JACC=J5
RLVL=R4
CALL ACCI
RETURN
C**** WEDGE
4 JX=5
RX=R3+.5*RSTJ2
C SHIFT A LITTLE TO RIGHT
41 RA=RMINI
RB=RA
IF(RINV.LT.0)RA=-RA
40 CALL MRKZ(JX,CENTR)
RETURN
C**** ACCENT
5 JX=1
RX=R3
GO TO 41
C**** STACCATO
7 RX=R3+6.7*RMINI
C PUSH DOT TO RIGHT
RG=9.
IF(IPLT.LT.0)RG=17.
C DOESN'T FILL DOT ON DPY
RB=14.
77 CALL RDRAW(1,RG,RDOT,RMINI,RX,CENTR+RSTJ2,RMINI)
RETURN
C**** TENUTO (DASH) (STARTS ABOVE)
9 CALL TENUTO(CENTR)
RETURN
C*** UPBOW, ETC.
11 JX=NXAC(J5-10)
RA=RMINI
RB=RA
RX=R3
GO TO 40
C*** 17=MORDENT 18=INVERTED MORDENT
17 RINV=J5
GO TO 26
C*** TRILL
20 JA=7
R5=0
J7=1
R7=1.
R8=J5-20
C R8 HAS THE ACCIDENTAL TO PUT OVER TR.
CALL ALPHA
RETURN
C*** HEAVY WEDGE
25 R7=0
ISTEM=2
IF(RINV.LT.0)ISTEM=1
RX4=R4
C*** FERMATA
26 CALL FERMTA
RETURN
C*** FINGERING
30 R5=J5-30
C GET THE 1 DIGIT NUM.
C PRINTS ONLY NUMS 0→5 AS FINGERINGS OVER NOTES.
RX=8.
C 8. SETS POS. AS IF NUM.WERE UNDER NOTE WITH STEM UP.
J3=R3+RX*RMINI
R6=.7
R7=0
R8=0
R9=0
R4=R4+2.5
CALL MAKNUM(R5)
C ADD HERE FOR NUMS WITH ACCENTS, ETC.
END